home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / STEP / STEPWRAP.S < prev   
Encoding:
Text File  |  1993-09-29  |  15.8 KB  |  587 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;
  3. ;;;     MODULE: STEPWRAP
  4. ;;;
  5. ;;;     Purpose:        This Module defines all procedures,
  6. ;;;                     which are neccessary to wrap an expression 
  7. ;;;                     that should be single steped.
  8. ;;;
  9. ;;;    Installation:    See "autostep.sc".
  10. ;;;
  11. ;;;     Notes:          All the procedures of this module are bound 
  12. ;;;                     in one environment called `step-environment'.
  13. ;;;                     This makes it easy to remove them with one
  14. ;;;                     `unbind' operation.
  15. ;;;                     The SCHEME code generated by this module 
  16. ;;;                     makes calls to some auxilary procedures, which
  17. ;;;                     should be bound in the `user-global-environment'. 
  18. ;;;                     The files "stepaux.sc" and "stepaux.fsl" 
  19. ;;;                     contain the source code and the compiled 
  20. ;;;                     code of these procedures.
  21. ;;;
  22. ;;;     Bugs:           000 Sometimes the procedure `stop-step' is
  23. ;;;                     called with the wrong environment.
  24. ;;;                     This will show some strange variables,
  25. ;;;                     if the `inspector' is called from `stop-step'
  26. ;;;                     to inspect the environment. Normally the
  27. ;;;                     right environment is among the environment
  28. ;;;                     parents of the inspected environment.
  29. ;;;                     
  30. ;;;                     001 If bigger procedures are stepped, the resulting 
  31. ;;;                     contains to many constants, so the compiler
  32. ;;;                     tabels may overflow.
  33. ;;;                     
  34. ;;;                     002 The expansion of a `step' expression may 
  35. ;;;                     consumes so much memory, that the system may
  36. ;;;                     run out of it.
  37. ;;;                     
  38. ;;;                     003 The expansion of a `step' expression 
  39. ;;;                     lasts to long.
  40. ;;;                     
  41. ;;;                     004 Due to the creation of additional environments
  42. ;;;                     the form `(eval <expr> <environment>)' can not
  43. ;;;                     be stepped. See bug 000.
  44. ;;;
  45. ;;;                     005 Quasiquotes are treated as a primitve,
  46. ;;;                     only their result is shown.
  47. ;;;
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49.  
  50. ;;; Define the step environment
  51. (define
  52.   step-environment
  53.   (make-environment
  54.  
  55. ;;; Converts symbols to downcase strings to display
  56. ;;; keyword symbols like `BEGIN' in downcase.
  57. (define (symbol->downcase-string sym)
  58.   (list->string
  59.     (map char-downcase
  60.      (string->list 
  61.        (symbol->string sym)))))
  62.  
  63. ;;; Recognizes a combination.
  64. ;;; In SCHEME every proper list is a combination.
  65. (define (combination? expr)
  66.   (pair? expr))
  67.  
  68.  
  69. ;;; Recognizes special forms
  70. (define (special? expr)
  71.   (member
  72.     expr 
  73.     '( if 
  74.        letrec let let* fluid-let
  75.        lambda named-lambda fluid-lambda
  76.        define set! 
  77.        quote quasiquote unquote unquote-splicing
  78.        access fluid 
  79.        unbound? fluid-bound?
  80.        delay freeze
  81.        begin begin0
  82.        eval)))
  83.  
  84.  
  85. ;;; Recognizes macros.
  86. ;;; This procedure depends on the implemenation details
  87. ;;; of PCS-SCHEME.
  88. (define (macro? expr)
  89.   (not 
  90.     (null? 
  91.       (getprop expr 'pcs*macro))))
  92.  
  93. ;;; Recognizes a variable.
  94. ;;; In SCHEME every symbol is a variable, 
  95. ;;; if it is not a keyword for a special form
  96. ;;; or macro. So it is important to test
  97. ;;; a symbol first for beeing a keyword,
  98. ;;; before testing it for a beeing a 
  99. ;;; variable.
  100. (define (variable? expr)
  101.   (symbol? expr))
  102.  
  103.  
  104.  
  105. ;;; This procedure produces code to
  106. ;;; show the values of the parameters of 
  107. ;;; a lambda expression.
  108. ;;; Special care is taken for optional
  109. ;;; arguments.
  110. (define (wrap-procedure-args args)
  111.   (if (null? args)
  112.       '()
  113.       (let loop 
  114.     ((arg 
  115.        (if (symbol? args)
  116.            args
  117.            (car args)))
  118.      (rest
  119.        (if (symbol? args)
  120.            '()
  121.            (cdr args))))
  122.     `((display "    parameter ") (display ',arg) (display " ==> ")
  123.       (pp ,arg)
  124.       (newline)
  125.       ,@(if (null? rest)
  126.         '()
  127.         (loop        
  128.           (if (symbol? rest)
  129.               rest
  130.               (car rest))
  131.           (if (symbol? rest)
  132.               '()
  133.               (cdr rest))))))))
  134.  
  135.  
  136. ;;; This procedure produces code to prepare a 
  137. ;;; `lambda', `named-lambda' or `fluid-lambda'
  138. ;;; for single steping. 
  139. ;;; For `lambda' and `named-lambda' expressions
  140. ;;; a call to `wrap-procedure-args' is made to
  141. ;;; produce code for displaying the parameter 
  142. ;;; values of the procedure to single step.
  143. ;;; Parameter of `fluid-lambda' expressions
  144. ;;; are handled directly by this procedure.
  145. (define (wrap-a-lambda keyword args exprs)
  146.   (define res (gensym))
  147.   `(begin
  148.      (display "    ") (display ,(symbol->downcase-string keyword)) (display " ==> ")
  149.      (newline)
  150.      (pp '(,keyword ,args ,@exprs))
  151.      (newline)
  152.      (stop-step (the-environment))
  153.      (,keyword
  154.        ,args
  155.        (if step-leap-mode
  156.        ((lambda ()
  157.           ,@exprs))
  158.        (begin
  159.          ,@(if (or (eq? keyword 'named-lambda)
  160.                (eq? keyword 'define))
  161.            `((display "    entry procedure ==> ")
  162.              (display ,(car args))           
  163.              (newline))
  164.            '((display "    entry procedure")
  165.              (newline)))
  166.          ,@(if (eq? keyword 'fluid-lambda)
  167.            (map (lambda (arg)
  168.               `(begin
  169.                  (newline)
  170.                  (display ',arg)
  171.                  (newline)
  172.                  (display "    fluid parameter ==> ")
  173.                  (pp (fluid ,arg))
  174.                  (newline)))
  175.             args)
  176.            (wrap-procedure-args 
  177.              (if (or (eq? keyword 'named-lambda)
  178.                  (eq? keyword 'define))
  179.              (cdr args)
  180.              args)))
  181. ;         (newline)
  182.          (stop-step (the-environment))
  183.          ((lambda (,res)
  184.         ,@(if (or (eq? keyword 'named-lambda)
  185.               (eq? keyword 'define))
  186.               `((display "    exit procedure ==> ")
  187.             (display ,(car args))           
  188.             (newline))
  189.               '((display "    exit procedure")
  190.             (newline)))
  191.         (display "    result ==> ")
  192.         (pp ,res)
  193.         (newline)
  194.         (stop-step (the-environment))
  195.         (set! step-leap-mode #F)
  196.         ,res)
  197.           ((lambda ()
  198.          ,@(wrap-a-list exprs)))))))))
  199.  
  200.  
  201.  
  202. ;;; This procedure produces the code
  203. ;;; for stepping a `define' clause.
  204. ;;; If the `define' clause defines a 
  205. ;;; procedure, the clause is converted
  206. ;;; to a defintion of simple variable.
  207. ;;; This conversion is done by a call
  208. ;;; to `expand-macro', which can be
  209. ;;; specific to TI-SCHEME.
  210. (define (wrap-a-define args exprs)
  211.   (let ((expanded-def
  212.       (expand-macro `(define ,args ,@exprs)))
  213.     (value (gensym)))
  214.     (let ((expanded-args  (cadr expanded-def))
  215.       (expanded-exprs (cddr expanded-def)))
  216.       `(define ,expanded-args
  217.      ((lambda (,value)
  218.         (display ',expanded-args)
  219.         (newline)
  220.         (display "    define ==> ")
  221.         (pp ,value)
  222.         (newline)
  223.         (stop-step (the-environment))
  224.         ,value)
  225.       (begin
  226.         (display "    define ==> ")
  227.         (pp '(define ,args ,@exprs))
  228.         (newline)
  229.         (stop-step (the-environment))
  230.         ,@(if (pair? args)
  231.           `((pp '(define ,args ,@exprs))
  232.             (newline)
  233.             (display "    procedure define ==> ")
  234.             (pp ',expanded-def)
  235.             (newline)
  236.             (stop-step (the-environment)))
  237.           '())
  238.         ,@(if (null? expanded-exprs)
  239.           `(,((lambda ()        ; an uninitialized variable is set
  240.             (define dummy)  ; to a special implementation dependent
  241.             dummy)))        ; value, that is returned by this proc.
  242.           `((step ,@expanded-exprs)))))))))
  243.  
  244.  
  245.  
  246. ;;; This procedure handels `set!' clauses, including
  247. ;;; `vector-set!'s and `fluid-set!'s.
  248. (define (wrap-a-set! arg expr)
  249.   (if (and (pair? arg)
  250.        (eq? (car arg) 'vector-ref))
  251.       `(begin
  252.      (pp '(set! ,arg ,@expr))
  253.      (newline)
  254.      (display "    vector-set! ==> ")
  255.      (pp ',(expand-macro `(set! ,arg ,@expr)))
  256.      (newline)
  257.      (stop-step (the-environment))
  258.      (step ,(expand-macro `(set! ,arg ,@expr))))
  259.       (let ((value (gensym)))
  260.     `(set! ,arg
  261.            ((lambda (,value)
  262.           (decrement-call-depth)
  263.           (display ',arg)
  264.           (newline)
  265.           (display "    set! ==> ")
  266.           (pp ,value)
  267.           (newline)
  268.           (stop-step (the-environment))
  269.           ,value)
  270.         (begin
  271.           (display "    set! ==> ")
  272.           (pp '(set! ,arg ,@expr))
  273.           (newline)
  274.           (stop-step (the-environment))
  275.           (increment-call-depth)
  276.           (step ,@expr)))))))
  277.  
  278.  
  279.  
  280.  
  281. ;;; This procedure produces code to step thru
  282. ;;; `let', `letrec' abd `let*' clauses.
  283. (define (wrap-a-let keyword name var-list exprs)
  284.   `(begin
  285.      (display ,(symbol->downcase-string keyword))
  286.      (display " ==> ")
  287.      (pp '(,keyword ,@name ,var-list ,@exprs))
  288.      (newline)
  289.      (stop-step (the-environment))
  290.      (,keyword
  291.        ,@name
  292.        ,(map
  293.       (lambda (var-binding)
  294.         (let ((value (gensym)))
  295.           `(,(car var-binding)
  296.          ((lambda (,value)
  297.             (display ',(car var-binding))
  298.             (newline)
  299.             (display "    bound ==> ")
  300.             (display ,value)
  301.             (newline)
  302.             (stop-step (the-environment))
  303.             ,value)
  304.           (step ,@(cdr var-binding))))))
  305.       var-list)
  306.        ,@(if (null? name)
  307.          `((display "    entry block")
  308.            (newline))
  309.          `((display "    entry block ==> ")
  310.            (display ',(car name))
  311.            (newline)))
  312.        (stop-step (the-environment))
  313.        ,(let ((value (gensym)))
  314.       `((lambda (,value)
  315.           ,@(if (null? name)
  316.             `((display "    exit block")
  317.               (newline)
  318.               (newline))
  319.             `((display "    exit block ==> ")
  320.               (display ',(car name))
  321.               (newline)
  322.               (newline)))  
  323.           (display "    result ==> ")
  324.           (display ,value)
  325.           (newline)
  326.           (stop-step (the-environment))
  327.           ,value)
  328.         ((lambda ()
  329.            ,@(wrap-a-list exprs))))))))
  330.  
  331.  
  332.  
  333. ;;; This procedure produces code to
  334. ;;; step through a list of argument
  335. ;;; expressions. 
  336. (define (wrap-a-list expr-list)
  337.   (map 
  338.     (lambda (sub-expr) `(step ,sub-expr))
  339.     expr-list))
  340.  
  341.  
  342.  
  343. ;;; This procedure produces code to
  344. ;;; step throug a call to a procedure.
  345. (define (wrap-a-call expr unwraped-expr)
  346.   (define prc (gensym))
  347.   (define args (gensym))
  348.   (define result (gensym))
  349.   `(begin
  350.      (increment-call-depth)
  351.      ((lambda (,prc . ,args)
  352.     (define ,result)
  353.     (decrement-call-depth)
  354.     (pp ',unwraped-expr)
  355.     (newline)
  356.     (display "    evaluation ==> ")
  357.     (newline)
  358.     (pp (cons ,prc ,args))
  359.     (newline)
  360.     (stop-step (the-environment))
  361.     (set! ,result (apply ,prc ,args))
  362.     (pp (cons ,prc ,args))
  363.     (newline)
  364.     (display "    application ==> ")
  365.     (pp ,result)
  366.     (newline)
  367.     (stop-step (the-environment))
  368.     ,result)
  369.       ,@expr)))
  370.  
  371.  
  372. (define (wrap-an-eval keyword unwraped-expr)
  373.   (define expr (gensym))
  374.   (define arg (gensym))
  375.   (define result (gensym))
  376.   (define code (car unwraped-expr))
  377.   (define envs (cdr unwraped-expr))
  378.   (if (null? envs)
  379.       `(begin
  380.      (increment-call-depth)
  381.      ((lambda (,expr)
  382.         (define ,result)
  383.         (decrement-call-depth)
  384.         (pp '(eval ,code))
  385.         (newline)
  386.         (display "    evaluation ==> ")
  387.         (newline)
  388.         (pp `(eval ,,expr))
  389.         (newline)
  390.         (stop-step (the-environment))
  391.         (set! ,result (eval `(step ,,expr)))
  392.         (pp `(eval ,,expr))
  393.         (newline)
  394.         (display "    application ==> ")
  395.         (pp ,result)
  396.         (newline)
  397.         (stop-step (the-environment))
  398.         ,result)
  399.       (begin
  400.         (newline)
  401.         (display "    evaluation ==> ")
  402.         (pp '(eval ,code))
  403.         (newline)
  404.         (stop-step (the-environment))
  405.         (step ,code))))
  406.       (error "can't handle this case")))
  407.  
  408.  
  409. ;;; This procedure produces code to
  410. ;;; step all kinds of special forms.
  411. ;;; Partly this done directly in this
  412. ;;; procedure, partly by calls to the
  413. ;;; special purpose procedures listed
  414. ;;; above.
  415. (define (wrap-special keyword args)
  416.   (case keyword
  417.     (if
  418.       (let ((value (gensym))
  419.         (pred (gensym))
  420.         (then-part (gensym))
  421.         (else-part (gensym)))
  422.     `(begin
  423.        (display "    if ==> ")
  424.        (pp '(if ,@args))
  425.        (newline)
  426.        (stop-step (the-environment))
  427.        (increment-call-depth)
  428.        (let ((,then-part ',(cadr args))
  429.          (,else-part ',(caddr args))
  430.          (,pred (step ,(car args))))
  431.          ((lambda (,value)
  432.         (decrement-call-depth)
  433.         (pp (append
  434.               '(if) 
  435.               (list ,pred)
  436.               (list ,then-part)
  437.               (list ,else-part)))
  438.         (newline)
  439.         (display "    if ==> ")
  440.         (pp ,value)
  441.         (newline)
  442.         (stop-step (the-environment))
  443.         ,value)
  444.           (if ,pred
  445.           (begin
  446.             (set! ,then-part (step ,(cadr args)))
  447.             ,then-part)
  448.           (begin
  449.             (set! ,else-part (step ,@(cddr args)))
  450.             ,else-part)))))))
  451.     ((quote 
  452.        quasiquote unquote unquote-splicing
  453.        access fluid 
  454.        delay freeze
  455.        unbound? fluid-bound?)
  456.      `(begin
  457.     (display ,(symbol->downcase-string keyword))
  458.     (display " ==> ")
  459.     (pp '(,keyword ,@args))
  460.     (newline)
  461.     (stop-step (the-environment))
  462.     (,keyword ,@args)))
  463.     ((begin begin0)
  464.      `(begin
  465.     (display ,(symbol->downcase-string keyword))
  466.     (display " ==> ")
  467.     (pp '(,keyword ,@args))
  468.     (newline)
  469.     (stop-step (the-environment))
  470.     (,keyword ,@(wrap-a-list args))))
  471.     ((lambda named-lambda fluid-lambda)
  472.      (wrap-a-lambda keyword (car args) (cdr args)))
  473.     ((letrec let* fluid-let)
  474.      (wrap-a-let keyword '() (car args) (cdr args)))
  475.     (let
  476.       (if (symbol? (car args))  ; is it a named let
  477.       (wrap-a-let 
  478.         keyword 
  479.         (list (car args))   ; name
  480.         (cadr args)         ; var-list
  481.         (cddr args))        ; exprs
  482.       (wrap-a-let keyword '() (car args) (cdr args))))
  483.     (define
  484.       (wrap-a-define (car args) (cdr args)))
  485.     (set!
  486.       (wrap-a-set! (car args) (cdr args)))
  487.     (eval
  488.       (wrap-an-eval keyword args))))
  489.  
  490.  
  491.  
  492. ;;; This procedure produces code to
  493. ;;; step a combination, that means a 
  494. ;;; `pair' of expressions.   
  495. (define (wrap-combination expr)
  496.   (cond ((special? (car expr))
  497.      (wrap-special (car expr) (cdr expr)))
  498.     ((macro? (car expr))
  499.      `(begin
  500.         (pp ',expr)
  501.         (newline)
  502.         (display "    macro ==> ")
  503.         (pp ',(expand-macro-1 expr))
  504.         (newline)
  505.         (stop-step (the-environment))
  506.         (step ,(expand-macro-1 expr))))
  507.     (else
  508.       `(begin
  509.          (display "    call ==> ")
  510.          (pp ',expr)
  511.          (newline)
  512.          (stop-step (the-environment))
  513.          ,(wrap-a-call (wrap-a-list expr) expr)))))
  514.  
  515.  
  516. ;;; This procedure produces code to
  517. ;;; to step all kinds of SCHEME expressions
  518. ;;; which can be steped. The trivial cases
  519. ;;; like numbers, variables and so on are
  520. ;;; handled directly by this procedure. 
  521. ;;; Combinations are handled by a call
  522. ;;; to `wrap-combination'.
  523. (define (wrap expr)
  524.   (cond ((combination? expr)
  525.      (wrap-combination expr))
  526.     ((number? expr)
  527.      `(begin (display "    number ==> ")
  528.          (pp ,expr)
  529.          (newline)
  530.          (stop-step (the-environment))
  531.          ,expr))
  532.     ((null? expr)
  533.      `(begin (display "    nil ==> ")
  534.          (pp ,expr)
  535.          (newline)
  536.          (stop-step (the-environment))
  537.          ,expr))
  538.     ((string? expr)
  539.      `(begin (display "    string ==> ")
  540.          (pp ,expr)
  541.          (newline)
  542.          (stop-step (the-environment))
  543.          ,expr))
  544.     ((char? expr)
  545.      `(begin (display "    character ==> ")
  546.          (pp ,expr)
  547.          (newline)
  548.          (stop-step (the-environment))
  549.          ,expr))
  550.     ((vector? expr)
  551.      `(begin (display "    vector ==> ")
  552.          (pp ,expr)
  553.          (newline)
  554.          (stop-step (the-environment))
  555.          ,expr))
  556.     ((variable? expr)
  557.      `(begin (display "    variable ") (write ',expr) (display " ==> ")
  558.          (pp ,expr)
  559.          (newline)
  560.          (stop-step (the-environment))
  561. ;         (if (closure? ,expr)
  562. ;             (apply-if (assq 'SOURCE (%reify ,expr 0))
  563. ;               (lambda (source)
  564. ;             (eval ((access wrap step-environment)
  565. ;                (list* 'named-lambda
  566. ;                       (cons (cdr (%reify ,expr 0)) (caddr source))
  567. ;                       (cdddr source)))))
  568. ;               ,expr)
  569. ;             ,expr) ")"
  570.          ,expr))
  571.  
  572.     (else
  573.       (error "could not single step expression:" expr))))
  574.  
  575.  
  576. ))      ; end of make-environment
  577.  
  578.  
  579. ;;; This is a simple form of the 
  580. ;;; defintion of the `step' macro
  581. ;;; which is included here for
  582. ;;; test purposes.
  583. ;(macro step
  584. ;  (lambda (expr)
  585. ;    ((access wrap step-environment) (cadr expr))))
  586.  
  587.